(FILECREATED " 3-FEB-74  0:33:42" RECORD

     changes to:  RECORDVARS,MAKECREATE,MAKECREATE1,RECORDECL1

     previous date: " 2-FEB-74  3:11:53")


(LISPXPRINT (QUOTE RECORDVARS) T)
(RPAQQ RECORDVARS ((FNS RECORD1 ADDGLOBVAR RECORDECL RECORDECL1 DECLTHISREC
SETUPARRAY 'CAR LISTRECORDEFS MAKERPLAC COMPOSE 'CDR DWIMIFYREC RECORDERROR
DECLSUBFIELD ADDFIELD) (FNS CLISPRECORD RECRESPELL MYSUBST RECLISPLOOKUP 
MYSUBST1 ACCESSDEF GETLOCALDEC) (FNS RECCOMPOSE0 RECORDWORD RECLOOK GENSYML)
(VARS CLISPRECORDTYPES CLISPRECORDWORDS CRLIST (RECORDSPLIST (LIST NIL)) (
CHANGEDRECLST NIL) (USERRECORDS NIL) (RECORDSUBSTFLG (QUOTE @@)) (
ACCESSNOTRANFLG T) (IN% DECL% FLAG) RECORDGENSYMVARS) (PROP CLISPWORD * 
CLISPRECORDWORDS) (PROP PRETTYTYPE RECORDS) (ADDVARS (PRETTYTYPELST (
CHANGEDRECLST RECORDS "records")) (PRETTYMACROS (RECORDS X (PD * (MAPCAR (QUOTE
X) (FUNCTION (LAMBDA (Z) (OR (LISTP Z) (LISTP (GETP Z (QUOTE CLISPRECORD)))
(ERROR Z "not a record")))))))) (SYSPROPS CLISPRECORD CLISPRECORDFIELD)) (FNS
CLISPNOTRAN MAKECREATE MAKECREATE1 MAKEINSTANCE SPECIFIED RECCOMPOSE 
MAKECREATELST SETPACK 'CONS BINDVAR 'PROGN) (BLOCKS (RECORDBLOCK (ENTRIES
RECORD1 CLISPRECORD RECORDECL RECCOMPOSE0) RECORD1 ADDGLOBVAR RECORDECL 
RECORDECL1 DECLTHISREC ADDFIELD SETUPARRAY 'CAR LISTRECORDEFS MAKERPLAC COMPOSE
'CDR DWIMIFYREC RECORDERROR DECLSUBFIELD CLISPRECORD RECRESPELL MYSUBST 
RECLISPLOOKUP MYSUBST1 ACCESSDEF GETLOCALDEC RECCOMPOSE0 RECORDWORD RECLOOK
CLISPNOTRAN MAKECREATE MAKECREATE1 MAKEINSTANCE SPECIFIED RECCOMPOSE 
MAKECREATELST SETPACK 'CONS 'PROGN BINDVAR GENSYML (GLOBALVARS CLISPRECORDWORDS
CLISPRECORDTYPES RECORDSPLIST RECORDSUBSTFLG RECORDSTATS USERRECORDS CRLIST
IN% DECL% FLAG RECORDGENSYMVARS) (SPECVARS EXPR FAULTFN VARS CLISPCHANGE 
REDECLARELST) (LOCALFREEVARS RECORD.HASHED CREATESTATEMENT BINDINGS BLIP 
FIELDS.IN.CREATE USINGTYPE RECEXPR DECLST YITEM XITEM RECORDECLARATION 
SUBRECSTODO GENSYMVARS USINGEXPR XFOUND YFOUND))) (PROP CLISPWORD TYPE type)))
(DEFINEQ

(RECORD1
(LAMBDA (DECL) (* This function does the work of the top level record 
declaration functions; all of the translating information is stored via 
RECORDECL; this just keeps track of the PROPS and of those record expressions
which have been changed (notice the MAPHASH thru the CLISPARRAY at the end))
(PROG ((FAULTFN (QUOTE TYPE-IN)) VARS (EXPR DECL) HASHED REDECLARELST TEM
NAME) (* EXPR, VARS, and FAULTFN are rebound because dwimifying of the defaults
is done with DWIMIFY1B, which assumes them) RETRY (COND ((AND (NULL TEM) (NULL
(CDDR DECL)) (EQ (CAR DECL) (CAR (SETQ TEM (GETP (CADR DECL) (QUOTE CLISPRECORD))))))
(* Feature: saying (RECORD FOO) if FOO has a CLISPRECORD PROP, just redeclares
FOO - Useful if you edit the property - Check for TEM keeps this from looping
infinitely) (SETQ DECL (CONS (CAR TEM) (CDR TEM))) (GO RETRY))) (OR (SETQ
HASHED (RECORDECL DECL T)) (RECORDERROR (QUOTE BADEC) DECL)) (COND ((SETQ
NAME (CADR HASHED)) (COND ((SETQ TEM (GETP NAME (QUOTE CLISPRECORD))) (SETQ
REDECLARELST (LIST (SETQ TEM (CAR (RECORDECL TEM (QUOTE DON'TFIX)))) NAME))
(* REDCLARELST is used for the MAPHASH - Here we get the RECORD name - Note
that REDECLARELST has the format ((list of fields) recordname)) (MAPC TEM
(FUNCTION (LAMBDA (X) (/REMPROP X (QUOTE CLISPRECORDFIELD)) (/DREMOVE X 
RECORDSPLIST)))) (AND (NULL DFNFLG) (LISPXPRINT (CONS (QUOTE record) (CONS
NAME (QUOTE (redeclared)))) T)))) (ADDGLOBVAR NAME (QUOTE USERRECORDS)) (/PUT
NAME (QUOTE CLISPRECORD) DECL))) (AND FILEPKGFLG (ADDGLOBVAR (OR NAME DECL)
(QUOTE CHANGEDRECLST))) (MAPC (CAR HASHED) (FUNCTION (LAMBDA (FIELD) (AND
(LITATOM FIELD) (PROG (TEM TEM2) (COND ((OR (SETQ TEM (GETP FIELD (QUOTE 
CLISPRECORDFIELD))) (FMEMB FIELD SYSPROPS)) (COND (REDECLARELST (OR (FMEMB
FIELD (CAR REDECLARELST)) (FRPLACA REDECLARELST (CONS FIELD (CAR REDECLARELST)))))
(T (SETQ REDECLARELST (LIST (LIST FIELD))))) (AND TEM (NULL DFNFLG) (LISPXPRINT
(CONS (QUOTE field) (CONS FIELD (NCONC1 (COND ((SETQ TEM2 (CADR (RECORDECL
TEM (QUOTE DON'TFIX)))) (LIST (QUOTE of) TEM2))) (QUOTE redeclared)))) T))))
(ADDSPELL FIELD RECORDSPLIST) (/PUT FIELD (QUOTE CLISPRECORDFIELD) DECL))))))
(AND REDECLARELST CLISPARRAY (MAPHASH CLISPARRAY (FUNCTION (LAMBDA (X Y) (AND
X (COND ((FMEMB (CAR Y) (QUOTE (fetch FETCH replace REPLACE))) (SOME (CDR
Y) (FUNCTION (LAMBDA (ZZ) (FMEMB ZZ (CAR REDECLARELST)))))) ((FMEMB (CAR Y)
CLISPRECORDWORDS) (EQ (CADR Y) (CADR REDECLARELST)))) (/PUTHASH Y NIL CLISPARRAY))))))
(RETURN NAME))))

(ADDGLOBVAR
(LAMBDA (VAL AT) (OR (COND ((LISTP VAL) (MEMBER VAL (CAR AT))) (T (FMEMB VAL
(CAR AT)))) (/RPLACA AT (CONS VAL (CAR AT))))))

(RECORDECL
(LAMBDA (DECL FLG) (* Fixes up the record declaration DECL if it hasn't already
been fixed, and get the "MEANING" of the declaration (stored in the CLISPTRAN)
; if the RECORD is in an intermediate state of translation, this "MEANING"
field is (NIL)) (* Each RECORD has the following properties: - NAME: the name
of a RECORD; subrecords have this only to match the appropriate field - -
FIELDS: a list of all fields contained in this RECORD and any subrecords;
used for lookup, and spelling correction - - TYPECHECK: a fn/form of how to
check type (this is optional, of course; not all RECORD types can be 
type-checked) - - CREATE: a fn/form of how to create an instance of this RECORD
- - FIELDINFO: a list of the field information for each field - - SUBFIELDS:
the subfields of the entire (!) RECORD - - DEFAULT: the universal default
(in default←form)) (* For each field (in fieldinfo) there is the following
information: - FIELDNAME: the name of this field - - DEFAULT: the default
value in a create - - ACCESSDEF: fn/form of what x:field means - - SETDEF:
fn/form of what x:field←value means - - SUBFIELDS: the sub-record declarations
for subfields) (COND ((NLISTP DECL) NIL) ((AND (EQ (CAR DECL) CLISPTRANFLG)
(FMEMB (CADDR DECL) CLISPRECORDTYPES)) (* Record begins with "CLISP%% ") (
RECORDECL1 (CADR DECL) (CDDR DECL) FLG)) ((NOT (FMEMB (CAR DECL) 
CLISPRECORDTYPES)) NIL) (T (RECORDECL1 (OR (GETHASH DECL CLISPARRAY) (PROG
(TEM) (SETQ TEM (LIST NIL)) (CLISPTRAN DECL TEM) (RETURN TEM))) (COND ((EQ
(CAR DECL) CLISPTRANFLG) (* Incase the CLISPTRAN above put a "CLISP " in)
(CDDR DECL)) (T DECL)) FLG)))))

(RECORDECL1
(LAMBDA (HASHED RECORDECLARATION FLG ACCESS) (* FLG is either NIL meaning
that the fields only are needed, T meaning that ALL the info is needed, or
a "superior" record declaration meaning that this is an internal (sub-record)
declaration) (PROG (TEM1 TEM2 TAIL) (COND ((OR IN% DECL% FLAG (EQ FLG (QUOTE
DON'TFIX))) (RETURN HASHED))) (OR HASHED (SETQ HASHED (CONS))) (COND ((NULL
(CDR HASHED)) (FRPLACA HASHED) (SETQ TEM1 (DECLTHISREC RECORDECLARATION FLG))
(RPLNODE HASHED (MAPCONC (CADR TEM1) (FUNCTION (LAMBDA (X) (AND (CAR X) (LIST
(CAR X)))))) TEM1))) (COND ((EQ (CAAR (CDDDDR HASHED)) (QUOTE NOT←DONE)) (AND
(CDAR (CDDDDR HASHED)) (PROG (LOCALVARS (TAIL (CDAR (CDDDDR HASHED))) DWIMDFLG
SUBRECSTODO) (SETQ LOCALVARS (CONS (QUOTE DEFAULT) (CAR HASHED))) LP (COND
((NULL TAIL) (MAPC (CDAR (CDDDDR HASHED)) (FUNCTION (LAMBDA (X) (DECLSUBFIELD
X HASHED)))) (RETURN)) ((AND (LISTP (CAR TAIL)) (OR (FMEMB (CAAR TAIL) 
CLISPRECORDTYPES) (AND (EQ (CAAR TAIL) CLISPTRANFLG) (FMEMB (CADAR TAIL) 
CLISPRECORDTYPES)))) (* Got a sub-record declaration - DECLSUBFIELD checks
if it is a subrecord, and inserts the appropriate info) (SETQ TAIL (CDR TAIL)))
((AND (FMEMB (CAR TAIL) LOCALVARS) (EQ (CADR TAIL) (QUOTE ←))) (PROG ((VARS
(APPEND LOCALVARS VARS))) (DWIMIFY1B TAIL RECORDECLARATION T T T FAULTFN))
(ADDFIELD (CAR TAIL) (CADDR TAIL) HASHED TAIL) (SETQ TAIL (CDDDR TAIL))) (T
(SELECTQ (CAR (LISTP (CAR TAIL))) ((SETQ SAVESETQ)) ((SETQQ SAVESETQQ) (/RPLNODE
(CAR TAIL) (QUOTE SETQ) (LIST (CADAR TAIL) (KWOTE (CADDR (CAR TAIL)))))) (COND
(DWIMDFLG (RECORDERROR (QUOTE NOFIELD) TAIL RECORDECLARATION)) (T (DWIMIFYREC
TAIL LOCALVARS RECORDECLARATION) (SETQ DWIMDFLG T) (GO LP)))) (COND ((FMEMB
(CADAR TAIL) LOCALVARS) (ADDFIELD (CADAR TAIL) (CADDR (CAR TAIL)) HASHED TAIL)
(SETQ TAIL (PROG1 (CDR TAIL) (/RPLNODE TAIL (CADAR TAIL) (CONS (QUOTE ←) (CONS
(CADDR (CAR TAIL)) (CDR TAIL))))))) ((FIXSPELL (CADAR TAIL) 70 LOCALVARS NIL
(CDAR TAIL) NIL T) (GO LP)) (T (RECORDERROR (QUOTE FIELDS) TAIL RECORDECLARATION)))))
(GO LP))) (MAP (CADDR HASHED) (FUNCTION (LAMBDA (Y) (AND (CAAR Y) (FASSOC
(CAAR Y) (CDR Y)) (RECORDERROR (QUOTE TWICE) (CAAR Y) RECORDECLARATION)))))
(RPLACA (CDDDDR HASHED) NIL))) (RETURN HASHED))))

(DECLTHISREC
(LAMBDA (RECORDECLARATION FLG) (PROG (NAME TYPECHECK FIELDINFO TAIL TEM1 TEM2
CREATEINFO) (SETQ NAME (CADR RECORDECLARATION)) (SETQ TAIL (CDDDR 
RECORDECLARATION)) (SETQ FIELDINFO (SELECTQ (CAR RECORDECLARATION) (RECORD
(LISTRECORDEFS (SETQ CREATEINFO (COND ((LISTP (CADR RECORDECLARATION)) (SETQ
NAME) (SETQ TAIL (CDDR RECORDECLARATION)) (CADR RECORDECLARATION)) (T (OR
(LISTP (CADDR RECORDECLARATION)) (RECORDERROR (QUOTE BADEC) RECORDECLARATION))
(CADDR RECORDECLARATION)))) (QUOTE BODY))) (TYPERECORD (COND ((LISTP (CADR
RECORDECLARATION)) (* (TYPERECORD (LIST))) (RECORDERROR (QUOTE BADEC) 
RECORDECLARATION))) (SETQ TYPECHECK (LIST (QUOTE EQ) (QUOTE (CAR BODY)) (KWOTE
NAME))) (LISTRECORDEFS (CONS NIL (CDR (SETQ CREATEINFO (CONS NAME (CADDR 
RECORDECLARATION))))) (QUOTE BODY))) ((PROPRECORD ATOMRECORD OPTIONS PROPS)
(SETQ TEM1 (COND ((LISTP (CADR RECORDECLARATION)) (SETQ NAME NIL) (SETQ TAIL
(CDDR RECORDECLARATION)) (CADR RECORDECLARATION)) ((NLISTP (CADDR 
RECORDECLARATION)) (SETQ TAIL) (CDDR RECORDECLARATION)) (T (CADDR 
RECORDECLARATION)))) (OR (AND (LISTP TEM1) (EVERY TEM1 (FUNCTION (LAMBDA (X
TAIL) (COND ((LITATOM X) (AND (NOT (STRPOSL (QUOTE (: ←)) X)) (OR (LISTP TAIL)
(NULL TAIL)))) (T (EVERY X (QUOTE LITATOM)))))))) (RECORDERROR (QUOTE BADEC)
RECORDECLARATION)) (* The decision of when to "CAR SKIP" (i.e. to insert an
extra field at the beginning of the record in order to have something to FRPLAC
into is: Yes, if this is a top-level declaration, or if it isn't the subfield
of a RECORD or TYPERECORD)) (COND ((EQ (CAR RECORDECLARATION) (QUOTE ATOMRECORD))
(SETQ TYPECHECK (QUOTE (LITATOM BODY)))) ((NOT (SETQ TEM2 (AND (OR (EQ (CAR
FLG) (QUOTE RECORD)) (EQ (CAR FLG) (QUOTE TYPERECORD))) (QUOTE (CDR BODY)))))
(SETQ CREATEINFO (CONS (CADR (SETQ TYPECHECK (LIST (QUOTE EQ) (KWOTE (OR NAME
(QUOTE PROPRECORD))) (QUOTE (CAR BODY))))) TEM1))) (T (SETQ CREATEINFO (CONS
NIL TEM1)))) (MAPCAR TEM1 (FUNCTION (LAMBDA (FIELD) (COND ((EQ (CAR 
RECORDECLARATION) (QUOTE ATOMRECORD)) (LIST FIELD (LIST (QUOTE GETP) (QUOTE
BODY) (KWOTE FIELD)) (LIST (QUOTE PUT) (QUOTE BODY) (KWOTE FIELD) (QUOTE ITEM))))
(T (LIST FIELD (LIST (QUOTE GET) (COND (TEM2 (QUOTE BODY)) (T (QUOTE (CDR
BODY)))) (KWOTE FIELD)) (PROGN (SETQ TEM1 (LIST (QUOTE PUTL) (QUOTE BODY)
(KWOTE FIELD) (QUOTE ITEM))) (COND (TEM2 (LIST (QUOTE RPLACD) (QUOTE BODY)
TEM2)) (T TEM2)))))))))) (ARRAYRECORD (SETQ TEM1 (COND ((LISTP (CADR 
RECORDECLARATION)) (SETQ NAME NIL) (SETQ TAIL (CDDR RECORDECLARATION)) (CADR
RECORDECLARATION)) ((NLISTP (CADDR RECORDECLARATION)) (SETQ TAIL) (CDDR 
RECORDECLARATION)) (T (CADDR RECORDECLARATION)))) (OR (AND (LISTP TEM1) (EVERY
TEM1 (FUNCTION (LAMBDA (X TAIL) (COND ((SMALLP X)) ((LISTP X) (AND (LITATOM
(CAR X)) (LITATOM (CDR X)))) ((LITATOM X) (AND (NOT (STRPOSL (QUOTE (: ←))
X)) (OR (LISTP TAIL) (NULL TAIL))))))))) (RECORDERROR (QUOTE BADEC) 
RECORDECLARATION)) (SETQ CREATEINFO) (SETQ TYPECHECK (QUOTE (ARRAYP BODY)))
(PROG (VAL (CNT 0)) LP (COND ((NULL TEM1) (SETQ CREATEINFO (CONS CNT CREATEINFO))
(RETURN VAL)) ((NUMBERP (CAR TEM1)) (SETQ CNT (IPLUS CNT (CAR TEM1)))) (T
(SETQ CNT (ADD1 CNT)) (COND ((CAR TEM1) (SETQ CREATEINFO (NCONC1 CREATEINFO
(CONS (CAR TEM1) CNT))) (COND ((OR (NLISTP (CAR TEM1)) (CAAR TEM1)) (SETQ
VAL (CONS (LIST (COND ((LISTP (CAR TEM1)) (CAAR TEM1)) (T (CAR TEM1))) (LIST
(QUOTE ELT) (QUOTE BODY) CNT) (LIST (QUOTE SETA) (QUOTE BODY) CNT (QUOTE ITEM)))
VAL)))) (COND ((AND (LISTP (CAR TEM1)) (CDR TEM1)) (SETQ VAL (LIST (LIST (CDR
TEM1) (LIST (QUOTE ELTD) (QUOTE BODY) CNT) (LIST (QUOTE SETD) (QUOTE BODY)
CNT)))))))))) (SETQ TEM1 (CDR TEM1)) (GO LP))) ((HASHRECORD HASHLINK) (SETQ
TEM1 (COND ((LISTP (CADR RECORDECLARATION)) (* (HASHLINK (FOO))) (COND ((FMEMB
(CAADR RECORDECLARATION) CLISPRECORDTYPES) (* (HASHLINK (RECORD --))) (SETQ
NAME) (SETQ TAIL (CDR RECORDECLARATION)) (LIST (GENSYM))) (T (SETQ NAME (AND
(NLISTP FLG) (CAADR RECORDECLARATION))) (SETQ TAIL (CDDR RECORDECLARATION))
(CADR RECORDECLARATION)))) ((NULL (CDR RECORDECLARATION)) (* (HASHLINK)) (
RECORDERROR (QUOTE BADEC) RECORDECLARATION)) ((NULL (CDDR RECORDECLARATION))
(* (HASHLINK FOO)) (COND ((LISTP FLG) (SETQ NAME))) (SETQ TAIL (CDDR 
RECORDECLARATION)) (LIST (CADR RECORDECLARATION))) ((FMEMB (CAR (LISTP (CADDR
RECORDECLARATION))) CLISPRECORDTYPES) (* (HASHLINK FOO (RECORD ---))) (SETQ
TAIL (CDDR RECORDECLARATION)) (LIST (GENSYM))) ((NLISTP (CADDR RECORDECLARATION))
(* (HASHLINK FIE FUM) means (HASHLINK FIE (FUM))) (LIST (CADDR RECORDECLARATION)))
(T (CADDR RECORDECLARATION)))) (SETQ TEM2 (COND ((AND (CDR TEM1) (NLISTP (CDR
TEM1))) (RECORDERROR (QUOTE BADEC) RECORDECLARATION)) ((NUMBERP (CADR TEM1))
(SETUPARRAY (OR (CADDR TEM1) (CAR TEM1)) (CADR TEM1))) (T (SETUPARRAY (CADR
TEM1) (CADDR TEM1))))) (LIST (LIST (SETQ CREATEINFO (CAR TEM1)) (CONS (QUOTE
GETHASH) (CONS (QUOTE BODY) TEM2)) (CONS (QUOTE PUTHASH) (CONS (QUOTE BODY)
(CONS (QUOTE ITEM) TEM2)))))) ((ACCESSFNS ACCESSFN) (OR (AND (EVERY (SETQ
TEM1 (COND ((LITATOM (CAR (SETQ TEM1 (COND ((LISTP (CADR RECORDECLARATION))
(SETQ TAIL (CDDR RECORDECLARATION)) (SETQ NAME) (CADR RECORDECLARATION)) (T
(CADDR RECORDECLARATION)))))) (LIST TEM1)) (T TEM1))) (FUNCTION (LAMBDA (X)
(AND (LISTP X) (LITATOM (CAR X)))))) (PROGN (MAPC TEM1 (FUNCTION (LAMBDA (X)
(DWIMIFYREC (CDR X) (QUOTE (BODY ITEM)) X)))) (EVERY TEM1 (FUNCTION (LAMBDA
(X) (NULL (CDDDR X))))))) (RECORDERROR (QUOTE BADEC) RECORDECLARATION)) TEM1)
(ARRAYRECORD (PROG ((CNT 0)))) (RECORDERROR (QUOTE BADEC) RECORDECLARATION)))
(RETURN (LIST NAME FIELDINFO TYPECHECK (CONS (QUOTE NOT←DONE) TAIL) (LIST
(CAR RECORDECLARATION) CREATEINFO))))))

(SETUPARRAY
(LAMBDA (NAME SIZE) (AND SIZE (NOT (NUMBERP SIZE)) (RECORDERROR (QUOTE BADEC)
SIZE RECORDECLARATION)) (OR (NULL NAME) (ARRAYP (CAR NAME)) (AND (NOT (LITATOM
NAME)) (RECORDERROR (QUOTE BADEC) NAME RECORDECLARATION)) (AND (LISTP (CAR
NAME)) (ARRAYP (CAAR NAME))) (SAVESET NAME (CONS (HARRAY (OR SIZE 100)))))
(AND NAME (LIST NAME))))

('CAR
(LAMBDA (X) (AND X (PROG (TEM) (COND ((OR (NLISTP X) (NULL (SETQ TEM (CADR
(FASSOC (CAR X) CRLIST))))) (LIST (QUOTE CAR) X)) (T (LIST TEM (CADR X))))))))

(LISTRECORDEFS
(LAMBDA (FORMAT DEF) (COND ((NULL FORMAT) NIL) ((LISTP FORMAT) (NCONC (AND
(CAR FORMAT) (LISTRECORDEFS (CAR FORMAT) ('CAR DEF))) (AND (CDR FORMAT) (
LISTRECORDEFS (CDR FORMAT) ('CDR DEF))))) ((LITATOM FORMAT) (LIST (LIST FORMAT
DEF (MAKERPLAC DEF)))) (T (RECORDERROR (QUOTE INVFIELD) FORMAT RECORDECLARATION))))
)

(MAKERPLAC
(LAMBDA (FORM) (PROG (TEM TEM2) (OR (SETQ TEM (CDDDR (FASSOC (COND ((LISTP
FORM) (CAR FORM)) (T FORM)) CRLIST))) (RETURN (AND (SELECTQ (CAR FORM) (GETHASH
(CONS (QUOTE PUTHASH) (CONS (CADR FORM) (CONS (QUOTE ITEM) (CDDR FORM)))))
(GET (COMPOSE (CONS (QUOTE PUTL) (CONS (QUOTE BODY) (CDDR FORM))) (CADR FORM)
T)) NIL) (HELP "IS THIS RIGHT?")))) (SETQ TEM2 (SELECTQ (CAR TEM) (CAR (QUOTE
RPLACA)) (CDR (QUOTE RPLACD)) (HELP))) (COND ((AND (NLISTP FORM) (NULL (CADR
TEM))) TEM2) (T (SETQ FORM (COND ((NLISTP FORM) (QUOTE BODY)) (T (CADR FORM))))
(LIST TEM2 (COND ((CADR TEM) (LIST (CADR TEM) FORM)) (T FORM)) (QUOTE ITEM))))))
)

(COMPOSE
(LAMBDA (EXPR1 EXPR2 RPLFLG) (* Make EXPR1 of EXPR2) (PROG NIL (COND ((LISTP
EXPR2)) ((EQ EXPR2 (QUOTE BODY)) (RETURN EXPR1)) (T (SETQ EXPR2 (LIST EXPR2
(QUOTE BODY))))) (COND ((NLISTP EXPR1) (CONS EXPR1 (CONS EXPR2 (COND (RPLFLG
(QUOTE (ITEM))) (T NIL))))) ((AND RPLFLG (EQ (CAR EXPR1) (QUOTE PUTL))) (PROG
((TEM2 (FASSOC (CAR EXPR2) CRLIST))) (RETURN (LIST (SELECTQ (CADDDR TEM2)
(CAR (QUOTE PUTLA)) (CDR (QUOTE PUTLD)) (GO NOCARCDR)) (COND ((CAR (CDDDDR
TEM2)) (LIST (CAR (CDDDDR TEM2)) (CADR EXPR2))) (T (CADR EXPR2))) (CADDR EXPR1)
(QUOTE ITEM))) NOCARCDR (HELP "error in record package" "function COMPOSE")))
(T (SUBST EXPR2 (QUOTE BODY) EXPR1))))))

('CDR
(LAMBDA (X) (AND X (PROG (TEM) (COND ((OR (NLISTP X) (NULL (SETQ TEM (CADDR
(FASSOC (CAR X) CRLIST))))) (LIST (QUOTE CDR) X)) (T (LIST TEM (CADR X))))))))

(DWIMIFYREC
(LAMBDA (TAIL NEWVARS PARENT) (PROG ((VARS (APPEND NEWVARS VARS))) (AND 
RECORDSUBSTFLG (SETQ VARS (CONS (QUOTE @) VARS))) (RESETVAR IN% DECL% FLAG
T (DWIMIFY1B TAIL PARENT TAIL T NIL FAULTFN)))))

(RECORDERROR
(LAMBDA (MESSAGE AT IN CDRFLG) (PROG (TEM) (FIXPRINTIN FAULTFN) (SETQ MESSAGE
(SELECTQ MESSAGE (NOTFIRSTFIELD "field from other than first sub-record specified")
(SUBFIELDNOTIMP "CREATE on records with subfields not implemented") (NOTIMP
"this feature not implemented in the record package yet:
") (OF "no OF") (NOCREATE "no CREATE specified") (INVFIELD "invalid record field")
(TWICE "Record field specified twice") (BOTH 
"both field and subfield specified in record declaration") (BADEC 
"bad record declaration") ((NOFIELD NOFIELDS) 
"missing a 'field←' in record expression ") (MISMATCH 
"Record subfield with no corresponding name in primary record") (FIELDS 
"Unrecognized field name") (COND ((AND (LISTP MESSAGE) (EQ (CDR MESSAGE) (QUOTE
BOTH))) (CONCAT "two subfields of " (CAR MESSAGE) 
" in different sub-records both have been specified")) (T MESSAGE)))) (COND
((NLISTP MESSAGE) (LISPXPRIN1 MESSAGE T)) (T (MAPRINT MESSAGE T NIL NIL NIL
NIL T))) (COND ((IGREATERP (POSITION T) 40) (LISPXTERPRI T))) (COND ((OR (EQ
AT IN) (NULL IN)) (LISPXPRIN1 " in  " T) (LISPXPRINT (RETDWIM2 AT) T) (ERROR!)))
(LISPXPRIN1 " at   " T) (COND ((AND AT (NLISTP AT)) (LISPXPRIN1 AT T) (
LISPXPRIN1 "    " T)) ((SETQ TEM (OR (NULL AT) (TAILP AT IN) (MEMB AT IN)))
(MAPRINT (RETDWIM2 (COND (CDRFLG (NLEFT IN 1 TEM)) (T TEM)) (CDDR AT)) T "... "
")
" NIL NIL T)) (T (LISPXPRINT (RETDWIM2 AT) T))) (LISPXPRIN1 "in    " T) (
LISPXPRINT (RETDWIM2 IN) T) (COND ((LISTP AT) (CDR AT)) ((NULL AT) (PROG1
IN (SETQ IN)))) IN (* Tell it that this is an external call) (ERROR!))))

(DECLSUBFIELD
(LAMBDA (SUBREC HASHED) (* DECLARATIONS: FAST) (PROG (SUBHASH SUBNAME TEM2
FLG) (COND ((NLISTP SUBREC) (RETURN)) ((EQ (CAR SUBREC) CLISPTRANFLG) (/RPLNODE2
SUBREC (CDDR SUBREC)))) (COND ((NOT (FMEMB (CAR SUBREC) CLISPRECORDTYPES))
(RETURN)) ((NOT (SETQ SUBHASH (PROGN (AND CLISPARRAY (GETHASH SUBREC NIL 
CLISPARRAY) (/PUTHASH SUBREC NIL CLISPARRAY)) (RECORDECL SUBREC RECORDECLARATION))))
(RECORDERROR (QUOTE BADEC) SUBREC RECORDECLARATION))) (COND ((SETQ SUBNAME
(CDR (FASSOC SUBREC SUBRECSTODO))) (AND (CADR SUBHASH) (RECORDERROR (QUOTE
BADEC) RECORDECLARATION)) (FRPLACA (CDR SUBHASH) SUBNAME)) (T (SETQ SUBNAME
(CADR SUBHASH)))) (COND ((AND (NOT (SETQ FLG (OR (EQ (CAADR (CDDDDR HASHED))
(QUOTE HASHLINK)) (EQ (CAADR (CDDDDR HASHED)) (QUOTE HASHRECORD))))) (OR (NULL
SUBNAME) (EQ (CADR HASHED) SUBNAME))) (* Same level - Name is NIL and not
a HASHLINK above) (PROG ((HASHED (CDDDDR HASHED))) (* Insert SUB declaration)
(FRPLACD (CDR HASHED) (CONS (CADDR HASHED) (NCONC1 (CDDDR HASHED) SUBHASH))))
(NCONC (CADDR HASHED) (APPEND (CADDR SUBHASH))) (* Insert FETCH and REPLACE
info) (NCONC (CAR HASHED) (APPEND (CAR SUBHASH))) (* Insert field names))
((SETQ TEM2 (COND (FLG (OR SUBNAME (FRPLACA (CDR SUBHASH) (CAAR HASHED)))
(* INSERT DUMMY NAME) (CAR (CADDR HASHED))) (T (FASSOC SUBNAME (CADDR HASHED)))))
(PROG ((HASHED (CDDDDR HASHED))) (* Insert the subfield) (FRPLACD (CDR HASHED)
(CONS (NCONC1 (CADDR HASHED) SUBHASH) (CDDDR HASHED)))) (FRPLACA (CDDR HASHED)
(NCONC (MAPCAR (CADDR SUBHASH) (FUNCTION (LAMBDA (X) (LIST (CAR X) (COMPOSE
(CADR X) (CADR TEM2)) (COMPOSE (CADDR X) (CADR TEM2)))))) (CADDR HASHED)))
(* Insert the field FETCH and REPLACE information) (FRPLACD (SETQ TEM2 (OR
(FMEMB (CAR TEM2) (CAR HASHED)) (FLAST (CAR HASHED)))) (APPEND (CAR SUBHASH)
(CDR TEM2))) (* Insert the field names)) (T (RECORDERROR (QUOTE MISMATCH)
SUBREC RECORDECLARATION))) (RETURN T))))

(ADDFIELD
(LAMBDA (VAR VAL HASHED TAIL) (COND ((FMEMB (CAR (LISTP VAL)) CLISPRECORDTYPES)
(SETQ SUBRECSTODO (CONS (CONS VAL VAR) SUBRECSTODO))) (T (PROG ((TEM (CADR
(CDDDDR HASHED)))) (COND ((FASSOC VAR (CADDR TEM)) (RECORDERROR (QUOTE TWICE)
TAIL RECORDECLARATION)) (T (FRPLACD (CDR TEM) (CONS (CONS (LIST VAR VAL) (CADDR
TEM)) (CDDDR TEM))))))))))
)
(DEFINEQ

(CLISPRECORD
(LAMBDA (RECEXPR FIELD SETQFLG) (LISPXWATCH RECORDSTATS) (PROG (DEF (DECLST
(GETLOCALDEC EXPR FAULTFN)) (CHECKFIELD FIELD) TAIL) (* Handles records. When
FIELD is NIL, RECEXPR is an expression such as (fetch --) or (replace --)
%. In this case, CLISPRECORD is to do the appropriate lookups and construct
the appropriate expresson, which it returns as its value. it should also do
the hashing. Note that even if there are no local declaration, only global
ones, it shuld still construct the expression and hash on it. If there are
no local or global declaration, return NIL. I will handle the error.) RETRY
(COND ((AND FIELD (NLISTP FIELD)) (* X : FIELD input) (COND (SETQFLG (COND
((SETQ DEF (ACCESSDEF FIELD DECLST RECEXPR T)) (* Return intermediate result
for next call) (RETURN (LIST (QUOTE replace) FIELD DEF RECEXPR))) (T (GO ERROR))))
((SETQ DEF (ACCESSDEF FIELD DECLST RECEXPR)) (SETQ RECEXPR (LIST (QUOTE fetch)
FIELD (QUOTE of) RECEXPR)) (GO GOTDEF)) (T (GO ERROR)))) (SETQFLG (OR (EQ
(CAR RECEXPR) (QUOTE replace)) (HELP (QUOTE (BAD ARG TO CLISPRECORD)))) (*
Second pass - Already done spelling correction) (SETQ DEF (CADDR RECEXPR))
(FRPLACA (CDDR RECEXPR) (QUOTE of)) (FRPLACD (CDDDR RECEXPR) (CONS (QUOTE
with) FIELD)) (GO GOTDEF)) ((NLISTP RECEXPR) (RETURN) (* X:NIL CASE)) (T (*
User typein) (SETQ CHECKFIELD (CADR RECEXPR)) (SETQ TAIL (CDR RECEXPR)) (SETQ
DEF (OR (SELECTQ (CAR RECEXPR) ((fetch FETCH) (ACCESSDEF CHECKFIELD DECLST
(CADDDR RECEXPR))) ((replace REPLACE) (ACCESSDEF CHECKFIELD DECLST (CADDDR
RECEXPR) T)) (HELP "BAD ARG TO CLISPRECORD" RECEXPR)) (GO ERROR))) (SELECTQ
(CADDR RECEXPR) ((of OF)) (OR (FIXSPELL (CADDR RECEXPR) 70 (QUOTE (OF of))
NIL (CDDR RECEXPR) NIL T) (RECORDERROR (QUOTE OF) (CDDR RECEXPR) RECEXPR)))
(SETQ TAIL (CDDDR RECEXPR)) (DWIMIFY1B TAIL RECEXPR T T T FAULTFN) (SELECTQ
(CAR RECEXPR) ((REPLACE replace) (SELECTQ (CADR TAIL) ((with WITH)) (OR (
FIXSPELL (CADR TAIL) 70 (QUOTE (WITH with)) NIL (CDR TAIL) NIL T) (/RPLACD
TAIL (CONS (QUOTE with) (CDDR TAIL)))))) NIL) (GO GOTDEF))) GOTDEF (* DEF
is either an atom; meaning a function of (one argument for access) (two 
arguments for REPLACE) ; or LISTP, meaning a FORM of with BODY and ITEM; BODY
being the thing the "FIELD" is taken of, and ITEM , optional, being the replaced
value) (CLISPTRAN RECEXPR (MYSUBST DEF (CADDDR RECEXPR) (CDR (CDDDDR RECEXPR))
DECLST)) (RETURN RECEXPR) ERROR (COND ((SETQ CHECKFIELD (RECRESPELL CHECKFIELD
DECLST TAIL)) (OR TAIL (SETQ FIELD CHECKFIELD)) (GO RETRY))))))

(RECRESPELL
(LAMBDA (FIELD DECLST TAIL) (FIXSPELL FIELD 70 (NCONC (MAPCONC DECLST (FUNCTION
(LAMBDA (X) (APPEND (CAR (RECORDECL X)))))) RECORDSPLIST) NIL TAIL NIL T)))

(MYSUBST
(LAMBDA (FORM XITEM YITEM DECLST) (COND ((EQ FORM (QUOTE BODY)) XITEM) ((NLISTP
FORM) (CONS (RECLISPLOOKUP FORM XITEM DECLST) (CONS XITEM YITEM))) (T (PROG
(XFOUND YFOUND) (MYSUBST1 FORM T))))))

(RECLISPLOOKUP
(LAMBDA (WORD VAR1 DECLST) (PROG ((LISPFN (GETP WORD (QUOTE LISPFN))) CLASSDEF)
(COND ((AND DECLST (SETQ CLASSDEF (GETP WORD (QUOTE CLISPCLASSDEF)))) (* must
do full lookup. Note that it is not necessary to do a call to CLISPLOOKUP0
if word has a CLASS, but no CLASSDEF, e.g. FGTP, FMEMB, etc., since if these
are ued as infix operators, they mean the corresponding functin regardless
of declaraton. I.e. The CLASSDEF property says that this is the name of an
infix operator. The CLASS property is used as a back pointer to the name of
the operator/class of which this word is a member.) (CLISPLOOKUP0 WORD VAR1
NIL DECLST LISPFN (GETP WORD (QUOTE CLISPCLASS)) CLASSDEF)) (T (OR LISPFN
WORD))))))

(MYSUBST1
(LAMBDA (FORM TOPFORM) (COND ((NLISTP FORM) NIL) ((EQ (CAR FORM) (QUOTE BODY))
(SETQ FORM (CONS (CAR FORM) (CDR FORM))) (COND ((NULL XFOUND) (SETQ XFOUND
(COND ((LISTP XITEM) FORM) (T T)))) ((LISTP XFOUND) (FRPLACA XFOUND (PROG
((TEM (BINDVAR))) (PROG1 (LIST (QUOTE SETQ) TEM XITEM) (SETQ XITEM TEM))))
(SETQ XFOUND T))) (RPLNODE FORM XITEM (OR (MYSUBST1 (CDR FORM)) (CDR FORM))))
((EQ (CAR FORM) (QUOTE ITEM)) (COND ((NULL (CDR FORM)) YITEM) (T (APPEND YITEM
(OR (MYSUBST1 (CDR FORM)) (CDR FORM)))))) (T (PROG (A D) (COND ((NLISTP (CAR
FORM)) (COND (TOPFORM (SETQ A (RECLISPLOOKUP (CAR FORM) XITEM DECLST)) (COND
((EQ A (CAR FORM)) (SETQ A NIL)))))) (T (SETQ A (MYSUBST1 (CAR FORM) T))))
(SETQ D (MYSUBST1 (CDR FORM))) (OR A D (RETURN)) (CONS (OR A (CAR FORM)) (OR
D (CDR FORM))))))))

(ACCESSDEF
(LAMBDA (FIELD DECLST VAR1 REPLACEFLG) (OR (AND (SETQ VAR1 (FASSOC FIELD (CADDR
(RECORDECL (OR (AND (COND ((EQ DECLST T) (SETQ DECLST (GETLOCALDEC EXPR)))
(T DECLST)) (CLISPLOOKUP0 FIELD VAR1 NIL DECLST NIL (QUOTE RECORDFIELD)))
(GETP FIELD (QUOTE CLISPRECORDFIELD))) (QUOTE DON'TFIX))))) (COND (REPLACEFLG
(OR (CADDR VAR1) (RECORDERROR "replacement of this field not defined" FIELD
RECEXPR))) (T (OR (CADR VAR1) (RECORDERROR "access of this field not defined"
FIELD RECEXPR))))) (COND ((FMEMB FIELD SYSPROPS) (COND (REPLACEFLG (LIST (QUOTE
PUT) (QUOTE BODY) (KWOTE FIELD) (QUOTE ITEM))) (T (LIST (QUOTE GETP) (QUOTE
BODY) (KWOTE FIELD)))))))))

(GETLOCALDEC
(LAMBDA (EXPR FN) (PROG (TEM) (RETURN (COND ((AND (EQ (CAR (SETQ TEM (CADDR
EXPR))) (QUOTE *)) (EQ (CADR TEM) (QUOTE DECLARATIONS:))) (CDDR TEM)) ((EQ
(CAR TEM) (QUOTE CLISP:)) (CLISPDEC0 TEM (OR FN FAULTFN))))))))
)
(DEFINEQ

(RECCOMPOSE0
(LAMBDA (CREATESTATEMENT) (LISPXWATCH RECORDSTATS) (PROG (HASHED DECL 
FIELDS.IN.CREATE USINGTYPE USING TEM2 CREATE (BLIP (CONS)) BINDINGS (GENSYMVARS
RECORDGENSYMVARS)) (* BLIP is used throughout the "COMPOSE" to indicate a
no-op) (SETQ CLISPCHANGE T) (OR (SETQ TEM2 (RECORDWORD (CAR CREATESTATEMENT)))
(HELP)) (COND ((EQ TEM2 (QUOTE type)) (OR (SETQ TEM2 (CADDDR (RECORDECL (RECLOOK
(CADR CREATESTATEMENT) (CDR CREATESTATEMENT) (GETLOCALDEC EXPR FAULTFN) 
CREATESTATEMENT) T))) (RECORDERROR "can't typecheck" CREATESTATEMENT)) (
DWIMIFY1B (CDDR CREATESTATEMENT) CREATESTATEMENT T T FAULTFN) (AND (CDDDR
CREATESTATEMENT) (RECORDERROR "too many expressions" (CDDDR CREATESTATEMENT)
CREATESTATEMENT)) (CLISPTRAN CREATESTATEMENT (MYSUBST TEM2 (CADDR 
CREATESTATEMENT))) (RETURN CREATESTATEMENT))) (PROG (TEM) (* find the "CREATE"
expression) LPX (COND ((SETQ CREATE (SOME CREATESTATEMENT (FUNCTION (LAMBDA
(X) (EQ (RECORDWORD X) (QUOTE create)))))) (SETQ HASHED (RECORDECL (SETQ DECL
(RECLOOK (CADR CREATE) (CDR CREATE) (GETLOCALDEC EXPR FAULTFN) CREATESTATEMENT))
T)))) (COND (TEM (OR CREATE (RECORDERROR (QUOTE NOCREATE) CREATESTATEMENT)))
(T (DWIMIFYREC (CDR CREATESTATEMENT) (NCONC (AND CREATE (APPEND (CAR HASHED)
(LIST (CADR CREATE)))) (APPEND CLISPRECORDWORDS)) CREATESTATEMENT) (COND ((NOT
CREATE) (SETQ TEM T) (GO LPX)))))) (SETQ DECL (CLISPNOTRAN DECL)) (PROG ((TEM
CREATESTATEMENT)) (* Go through the create statement, picking up the field←'s
and the USING or COPYING, etc) LP2 (COND ((NULL TEM) (RETURN)) ((SETQ TEM2
(RECORDWORD (CAR TEM))) (SELECTQ TEM2 ((CREATE create) (* already handled)
T) (COND (USING (RECORDERROR (COND ((EQ (CAR TEM) (CAR USING)) (CONCAT (CAR
TEM) " appears twice")) (T (CONCAT "both " (CAR TEM) " and " (CAR USING))))
TEM CREATESTATEMENT)) (T (SETQ USINGTYPE TEM2) (SETQ USING TEM)))) (SETQ TEM
(CDDR TEM))) (T (* Adds the info to alist, or ERROR's - let it handle 
unrecognized NLISTP's as well) (COND ((NLISTP (CAR TEM)) (RECORDERROR (QUOTE
NOFIELDS) TEM CREATESTATEMENT))) (SELECTQ (CAAR TEM) ((SETQ SAVESETQ)) ((SETQQ
SAVESETQQ) (/RPLNODE (CAR TEM) (QUOTE SETQ) (LIST (CADAR TEM) (KWOTE (CADDR
(CAR TEM)))))) (RECORDERROR (QUOTE NOFIELD) TEM CREATESTATEMENT)) (COND ((FASSOC
(CADAR TEM) FIELDS.IN.CREATE) (RECORDERROR (QUOTE TWICE) TEM CREATESTATEMENT))
((FMEMB (CADAR TEM) (CAR HASHED)) (SETQ FIELDS.IN.CREATE (CONS (CDAR TEM)
FIELDS.IN.CREATE)) (SETQ TEM (PROG1 (CDR TEM) (/RPLNODE TEM (CADAR TEM) (CONS
(QUOTE ←) (CONS (CADDR (CAR TEM)) (CDR TEM))))))) ((FIXSPELL (CADAR TEM) 70
(CAR HASHED) NIL (CDAR TEM) NIL T) (GO LP2)) (T (RECORDERROR (QUOTE FIELDS)
TEM CREATESTATEMENT))))) (GO LP2)) (SETQ TEM2 (RECCOMPOSE HASHED (AND USINGTYPE
(COND ((LISTP (CADR USING)) (BINDVAR (CADR USING))) (T (CADR USING)))))) (AND
BINDINGS (SETQ TEM2 (CONS (QUOTE PROG) (CONS (DREVERSE BINDINGS) (COND ((EQ
(CAR TEM2) (QUOTE PROGN)) (FRPLACA (LAST TEM2) (LIST (QUOTE RETURN) (CAR (LAST
TEM2)))) (CDR TEM2)) (T (LIST (LIST (QUOTE RETURN) TEM2)))))))) (CLISPTRAN
CREATESTATEMENT TEM2) (OR (AND (EQ (CAR CREATESTATEMENT) (CAR CREATE)) (EQUAL
(CDR CREATESTATEMENT) (SETQ TEM2 (CONS (CADR CREATE) (NCONC (AND USING (LIST
(CAR USING) (CADR USING))) (SETPACK FIELDS.IN.CREATE)))))) (/RPLNODE 
CREATESTATEMENT (CAR CREATE) TEM2)) (RETURN CREATESTATEMENT))))

(RECORDWORD
(LAMBDA (WORD) (AND (EQ (CAR (SETQ WORD (GETP WORD (QUOTE CLISPWORD)))) (QUOTE
RECORDWORD)) (COND ((LISTP (CDR WORD)) (CADDR WORD)) (T (CDR WORD))))))

(RECLOOK
(LAMBDA (RECNAME TAIL LOCALDEC PARENT) (* LOOKS FOR RECORD DECLARATION) (PROG
(TEM) RETRY (OR (COND ((NLISTP RECNAME) (OR (AND LOCALDEC (CLISPLOOKUP0 RECNAME
NIL NIL LOCALDEC NIL (QUOTE RECORD))) (GETP RECNAME (QUOTE CLISPRECORD)) (COND
((SETQ TEM (FIXSPELL RECNAME 70 (NCONC (MAPCONC LOCALDEC (FUNCTION (LAMBDA
(X) (SETQ X (RECORDECL X)) (LIST (CADR X))))) USERRECORDS) NIL TAIL NIL T))
(SETQ RECNAME TEM) (GO RETRY))))) ((FMEMB (CAR RECNAME) CLISPRECORDTYPES)
RECNAME)) (RECORDERROR "Undefined record name" TAIL PARENT)))))

(GENSYML
(LAMBDA NIL (OR (CAR (SETQ GENSYMVARS (CDR GENSYMVARS))) (GENSYM))))
)
(RPAQQ CLISPRECORDTYPES (RECORD TYPERECORD OPTIONS PROPRECORD HASHLINK ACCESSFN
HASHRECORD ATOMRECORD ARRAYRECORD ACCESSFNS MATCHRECORD))
(RPAQQ CLISPRECORDWORDS (SMASHING COPYREUSING CREATE USING COPYING REUSING
create using copying reusing copyreusing smashing))
(RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL) (CDR CADR CDDR CDR NIL) (CDDDDR NIL
NIL CDR CDDDR) (CADDDR NIL NIL CAR CDDDR) (CDDDR CADDDR CDDDDR CDR CDDR) (CDADDR
NIL NIL CDR CADDR) (CAADDR NIL NIL CAR CADDR) (CADDR CAADDR CDADDR CAR CDDR)
(CDDR CADDR CDDDR CDR CDR) (CDDADR NIL NIL CDR CDADR) (CADADR NIL NIL CAR
CDADR) (CDADR CADADR CDDADR CDR CADR) (CDAADR NIL NIL CDR CAADR) (CAAADR NIL
NIL CAR CAADR) (CAADR CAAADR CDAADR CAR CADR) (CADR CAADR CDADR CAR CDR) (CDDDAR
NIL NIL CDR CDDAR) (CADDAR NIL NIL CAR CDDAR) (CDDAR CADDAR CDDDAR CDR CDAR)
(CDADAR NIL NIL CDR CADAR) (CAADAR NIL NIL CAR CADAR) (CADAR CAADAR CDADAR
CAR CDAR) (CDAR CADAR CDDAR CDR CAR) (CDDAAR NIL NIL CDR CDAAR) (CADAAR NIL
NIL CAR CDAAR) (CDAAR CADAAR CDDAAR CDR CAAR) (CDAAAR NIL NIL CDR CAAAR) (CAAAAR
NIL NIL CAR CAAAR) (CAAAR CAAAAR CDAAAR CAR CAAR) (CAAR CAAAR CDAAR CAR CAR)))
(RPAQ RECORDSPLIST (LIST NIL))
(RPAQ CHANGEDRECLST NIL)
(RPAQ USERRECORDS NIL)
(RPAQQ RECORDSUBSTFLG @@)
(RPAQ ACCESSNOTRANFLG T)
(RPAQ IN% DECL% FLAG)
(RPAQQ RECORDGENSYMVARS ($$LST1 $$LST2 $$LST3 $$LST4 $$LST5))
(DEFLIST(QUOTE(
(SMASHING (RECORDWORD . smashing))
(COPYREUSING NIL)
(CREATE (RECORDWORD . create))
(USING (RECORDWORD . using))
(COPYING (RECORDWORD . copying))
(REUSING (RECORDWORD . reusing))
(create (RECORDWORD . create))
(using (RECORDWORD . using))
(copying (RECORDWORD . copying))
(reusing (RECORDWORD . reusing))
(copyreusing NIL)
(smashing NIL)
))(QUOTE CLISPWORD))

(DEFLIST(QUOTE(
(RECORDS (LAMBDA (X Y) (AND (EQ (CAR X) Y) (CDR X))))
))(QUOTE PRETTYTYPE))

(ADDTOVAR PRETTYTYPELST (CHANGEDRECLST RECORDS "records"))
(ADDTOVAR PRETTYMACROS (RECORDS X (PD * (MAPCAR (QUOTE X) (FUNCTION (LAMBDA
(Z) (OR (LISTP Z) (LISTP (GETP Z (QUOTE CLISPRECORD))) (ERROR Z "not a record"))))))))
(ADDTOVAR SYSPROPS CLISPRECORD CLISPRECORDFIELD)
(DEFINEQ

(CLISPNOTRAN
(LAMBDA (X) (* This function doesn't really do much; it is just A canonical
way of checking for the CLISPTRANFLG; i really shouldn't worry about it working
when the CLISPARRAY is off; but, well, i did it) (COND ((AND (LISTP X) (EQ
(CAR X) CLISPTRANFLG)) (CDDR X)) (T X))))

(MAKECREATE
(LAMBDA (RECORD.HASHED USINGEXPR) (PROG ((CREATEINFO (CADR (CDDDDR RECORD.HASHED)))
TEM TEM2) (COND ((EQ USINGTYPE (QUOTE reusing)) (OR (SPECIFIED RECORD.HASHED)
(RETURN BLIP)))) (COND ((SETQ TEM (SOME (CDDDR (CDDDDR RECORD.HASHED)) (FUNCTION
(LAMBDA (X) (AND (FMEMB (CAR (CADR (CDDDDR X))) (QUOTE (HASHLINK HASHRECORD)))
(OR (NULL (CADR X)) (EQ (CADR X) (CADR RECORD.HASHED)))))))) (* There is a
"HASHLINK" brother to this RECORD; we ignore hashlinks otherwise) (PROG ((VALUE
(PROG ((RECORD.HASHED (CAR TEM))) (* Create the HASHLINK item) (MAKEINSTANCE
(CADR (CADR (CDDDDR (CAR TEM)))) NIL USINGEXPR T T (COND ((EQ USINGTYPE (QUOTE
reusing)) (QUOTE using)) (T USINGTYPE))))) (NAME (CADR (CADR (CDDDDR (CAR
TEM)))))) (SETQ TEM2 (MAKECREATE1 CREATEINFO T)) (* CREATE THE BODY) (COND
((NULL VALUE) (* IF THE HASHLINK ISNT THERE, SINCE THE CREATE WILL HAVE ALWAYS
CREATED NEW STRUCTRE, NO POINT IN MAKING A NEW STRUCTURE) TEM2) (T (MYSUBST
(LIST (QUOTE PROGN) (CADDR (FASSOC NAME (CADDR (CAR TEM)))) (QUOTE BODY))
(SETQ TEM2 (COND ((NLISTP TEM2) TEM2) ((EQ TEM2 BLIP) ('CONS ('CAR USINGEXPR)
('CDR USINGEXPR))) (T TEM2))) (LIST VALUE)))))) (T (MAKECREATE1 CREATEINFO))))))

(MAKECREATE1
(LAMBDA (CREATEINFO HASHFLAG) (PROG (TEM TEM2) (SELECTQ (CAR CREATEINFO) (RECORD
(MAKECREATELST (CADR CREATEINFO) T USINGEXPR)) (TYPERECORD ('CONS (KWOTE (CAADR
CREATEINFO)) (MAKECREATELST (CDADR CREATEINFO) T USINGEXPR))) (PROPRECORD
(SETQ TEM (PROG (($$LST1 (CDADR CREATEINFO)) $$VAL X TEM) $$LP (SETQ X (CAR
$$LST1)) (COND ((NULL $$LST1) (RETURN $$VAL)) ((NEQ (SETQ TEM (MAKEINSTANCE
(SETQ X (OR (CAR (LISTP X)) X)) NIL USINGEXPR T T (AND USINGTYPE (QUOTE reusing))))
BLIP) (SETQ $$VAL (NCONC1 $$VAL (LIST (KWOTE X) TEM))))) (SETQ $$LST1 (CDR
$$LST1)) (GO $$LP))) (COND ((NULL USINGTYPE) (COND ((AND (NULL (CAADR CREATEINFO))
(EVERY TEM (FUNCTION (LAMBDA (X) (NULL (CADR X)))))) (COND (HASHFLAG (CAR
TEM)) (T NIL))) (T (CONS (QUOTE LIST) (NCONC (AND (CAADR CREATEINFO) (LIST
(CAADR CREATEINFO))) (MAPCONC TEM (FUNCTION (LAMBDA (X) (IF X:2=NIL THEN NIL
ELSE X))))))))) (T (SETQ TEM2 (MYSUBST (SELECTQ USINGTYPE (copying (QUOTE
COPY)) (QUOTE APPEND)) USINGEXPR)) (MAPC TEM (FUNCTION (LAMBDA (X) (SETQ TEM2
(LIST (COND ((CAADR CREATEINFO) (QUOTE PUTLD)) (T (QUOTE PUTL))) TEM2 (CAR
X) (CADR X)))))) TEM2))) (ARRAYRECORD (PROG (TEM EXPRESSION TEM1 TEM2) (SETQ
TEM (BINDVAR (LIST (QUOTE ARRAY) (CAADR CREATEINFO) NIL (CADR (FASSOC (QUOTE
DEFAULT) (CADDR CREATEINFO)))))) (SETQ TEM1 (CDADR CREATEINFO)) (PROG (I)
(SETQ I 1) $$LP (COND ((IGREATERP I (CAADR CREATEINFO)) (RETURN NIL))) (PROGN
(COND ((EQ (CDAR TEM1) I) (SETQ TEM2 (MAKEINSTANCE (CAAR TEM1) NIL USINGEXPR
NIL T USINGTYPE)) (SETQ TEM1 (CDR TEM1))) (USINGTYPE (SETQ TEM2 (LIST (QUOTE
ELT) USINGEXPR I)) (COND ((EQ USINGTYPE (QUOTE copying)) (SETQ TEM2 (LIST
(QUOTE COPY) TEM2))))) (T (SETQ TEM2 BLIP))) (COND ((NEQ BLIP TEM2) (SETQ
EXPRESSION (CONS (LIST (QUOTE SETA) TEM I TEM2) EXPRESSION))))) (SETQ I (IPLUS
I 1)) (GO $$LP)) (RETURN (CONS (QUOTE PROGN) (DREVERSE (CONS TEM EXPRESSION))))))
((HASHLINK HASHRECORD) (HELP)) (RECORDERROR (LIST "CREATE of " (CAR CREATEINFO)
"'s not implemented.") CREATESTATEMENT)))))

(MAKEINSTANCE
(LAMBDA (NAME ERMESS USINGEXPR USEUNIVDEFAULT COMPOSEWITHUSING USETYPE) (PROG
(TEM (VALUE (CDR (FASSOC NAME FIELDS.IN.CREATE))) (SUBFIELDS (SOME (CADDR
(CDDDDR RECORD.HASHED)) (FUNCTION (LAMBDA (X) (AND (EQ (CADR X) NAME) (NOT
(FMEMB (CAADR (CDDDDR X)) (QUOTE (HASHLINK HASHRECORD))))))))) (DEFAULTS (CADDR
(CADR (CDDDDR RECORD.HASHED)))) TEM2) (SETQ VALUE (COND (VALUE (PROG ((VALUE
(COND ((AND RECORDSUBSTFLG USETYPE) (SUBST (COND (COMPOSEWITHUSING (MYSUBST
(CADR (FASSOC NAME (CADDR RECORD.HASHED))) USINGEXPR)) (T USINGEXPR)) 
RECORDSUBSTFLG (CAR VALUE))) (T (CAR VALUE)))) (USINGTYPE (QUOTE reusing)))
(RETURN (COND ((SPECIFIED (CAR SUBFIELDS)) (MAKECREATE (CAR SUBFIELDS) VALUE))
(T VALUE))))) (USETYPE (PROG ((USINGEXPR (COND (COMPOSEWITHUSING (MYSUBST
(CADR (FASSOC NAME (CADDR RECORD.HASHED))) USINGEXPR)) (T USINGEXPR)))) (RETURN
(SELECTQ USETYPE (reusing (COND ((SPECIFIED (CAR SUBFIELDS)) (MAKECREATE (CAR
SUBFIELDS) USINGEXPR)) (ERMESS (RECORDERROR ERMESS CREATESTATEMENT)) (T BLIP)))
(COND (SUBFIELDS (MAKECREATE (CAR SUBFIELDS) USINGEXPR)) (T (SELECTQ USETYPE
(copying (LIST (QUOTE COPY) USINGEXPR)) USINGEXPR))))))) (SUBFIELDS (MAKECREATE
(CAR SUBFIELDS))) ((SETQ TEM (FASSOC NAME DEFAULTS)) (CADR TEM)) (USEUNIVDEFAULT
(CADR (FASSOC (QUOTE DEFAULT) DEFAULTS))) (T BLIP))) (RETURN (COND ((SETQ
TEM (SOME (CADDR (CDDDDR RECORD.HASHED)) (FUNCTION (LAMBDA (X) (AND (EQ (CADR
X) NAME) (FMEMB (CAADR (CDDDDR X)) (QUOTE (HASHLINK HASHRECORD)))))))) (COND
((EQ (SETQ TEM2 (MAKEINSTANCE (CADR (CADR (CDDDDR (CAR TEM)))) NIL (COND (
COMPOSEWITHUSING (MYSUBST (CADR (FASSOC NAME (CADDR RECORD.HASHED))) USINGEXPR))
(T USINGEXPR)) T T (COND ((EQ USETYPE (QUOTE using)) (QUOTE reusing)) (T USETYPE))))
BLIP) VALUE) (T (MYSUBST (LIST (QUOTE PROGN) (CADDR (FASSOC (CADR (CADR (CDDDDR
(CAR TEM)))) (CADDR (CAR TEM)))) (QUOTE BODY)) VALUE (LIST TEM2))))) (T VALUE)))))
)

(SPECIFIED
(LAMBDA (RECORD.HASHED) (SOME (CAR RECORD.HASHED) (FUNCTION (LAMBDA (X) (FASSOC
X FIELDS.IN.CREATE))))))

(RECCOMPOSE
(LAMBDA (RECORD.HASHED USINGEXPR) (PROG ((TEM (MAKECREATE RECORD.HASHED 
USINGEXPR))) (COND ((EQ TEM BLIP) (RECORDERROR "REUSING with no fields specified;"
CREATESTATEMENT)) (T TEM)))))

(MAKECREATELST
(LAMBDA (TEMPLATE CARFLG USINGEXPR) (COND ((NLISTP TEMPLATE) (MAKEINSTANCE
TEMPLATE NIL USINGEXPR (OR TEMPLATE CARFLG) NIL USINGTYPE)) (T (PROG ((A (
MAKECREATELST (CAR TEMPLATE) T ('CAR USINGEXPR))) (D (MAKECREATELST (CDR 
TEMPLATE) NIL ('CDR USINGEXPR)))) (COND ((AND (EQ A BLIP) (EQ D BLIP)) BLIP)
(T ('CONS (COND ((EQ A BLIP) ('CAR USINGEXPR)) (T A)) (COND ((EQ D BLIP) ('CDR
USINGEXPR)) (T D))))))))))

(SETPACK
(LAMBDA (ALIST) (MAPCONC ALIST (FUNCTION (LAMBDA (TEM) (AND (CDR TEM) (LIST
(CAR TEM) (QUOTE ←) (CADR TEM))))))))

('CONS
(LAMBDA (CARPART CDRPART) (COND ((OR (EQ (CAR CDRPART) (QUOTE LIST)) (NOT
(CAR CDRPART))) (CONS (QUOTE LIST) (CONS CARPART (CDR CDRPART)))) (T (LIST
(QUOTE CONS) CARPART CDRPART)))))

(BINDVAR
(LAMBDA (VAL) (COND ((NULL VAL) (CAR (SETQ BINDINGS (CONS (GENSYML) BINDINGS))))
(T (SETQ BINDINGS (CONS (LIST (GENSYML) VAL) BINDINGS)) (CAAR BINDINGS)))))

('PROGN
(LAMBDA N (COND ((NOT (IGREATERP N 0)) NIL) ((EQ N 1) (ARG N N)) (T (CONS
(QUOTE PROGN) (PROG (VAL I TEM) (SETQ I 1) LP (COND ((IGREATERP I N) (RETURN
VAL))) (SETQ VAL (NCONC VAL (COND ((EQ (CAR (SETQ TEM (ARG N I))) (QUOTE PROGN))
(APPEND (CDR TEM))) (T (LIST TEM))))) (SETQ I (IPLUS I 1)) (GO LP)))))))
)
(DECLARE
(BLOCK: RECORDBLOCK (ENTRIES RECORD1 CLISPRECORD RECORDECL RECCOMPOSE0) RECORD1
ADDGLOBVAR RECORDECL RECORDECL1 DECLTHISREC ADDFIELD SETUPARRAY 'CAR 
LISTRECORDEFS MAKERPLAC COMPOSE 'CDR DWIMIFYREC RECORDERROR DECLSUBFIELD 
CLISPRECORD RECRESPELL MYSUBST RECLISPLOOKUP MYSUBST1 ACCESSDEF GETLOCALDEC
RECCOMPOSE0 RECORDWORD RECLOOK CLISPNOTRAN MAKECREATE MAKECREATE1 MAKEINSTANCE
SPECIFIED RECCOMPOSE MAKECREATELST SETPACK 'CONS 'PROGN BINDVAR GENSYML (
GLOBALVARS CLISPRECORDWORDS CLISPRECORDTYPES RECORDSPLIST RECORDSUBSTFLG 
RECORDSTATS USERRECORDS CRLIST IN% DECL% FLAG RECORDGENSYMVARS) (SPECVARS
EXPR FAULTFN VARS CLISPCHANGE REDECLARELST) (LOCALFREEVARS RECORD.HASHED 
CREATESTATEMENT BINDINGS BLIP FIELDS.IN.CREATE USINGTYPE RECEXPR DECLST YITEM
XITEM RECORDECLARATION SUBRECSTODO GENSYMVARS USINGEXPR XFOUND YFOUND))
)(DEFLIST(QUOTE(
(TYPE (RECORDWORD . type))
(type (RECORDWORD . type))
))(QUOTE CLISPWORD))

STOP